Amiga Tools 2/Amiga Tools 2.iso/tools/jade/lisp/compiler.jlc

Text File | 1995-03-09 | 18KB | 485 lines

;;; Source file: /usr/local/lib/jade/3.2/lisp/compiler.jl
;;; Compiled by jsh@orcrist on Sun Oct 16 20:21:16 1994
;;; Jade 3.2

(provide (quote compiler))

(defvar comp-write-docs nil 92938)

(defconst op-call 8)

(defconst op-push 16)

(defconst op-vrefc 24)

(defconst op-vsetc 32)

(defconst op-list 40)

(defconst op-bind 48)

(defconst op-last-with-args 55)

(defconst op-vref 64)

(defconst op-vset 65)

(defconst op-fref 66)

(defconst op-fset 67)

(defconst op-init-bind 68)

(defconst op-unbind 69)

(defconst op-dup 70)

(defconst op-swap 71)

(defconst op-pop 72)

(defconst op-nil 73)

(defconst op-t 74)

(defconst op-cons 75)

(defconst op-car 76)

(defconst op-cdr 77)

(defconst op-rplaca 78)

(defconst op-rplacd 79)

(defconst op-nth 80)

(defconst op-nthcdr 81)

(defconst op-aset 82)

(defconst op-aref 83)

(defconst op-length 84)

(defconst op-eval 85)

(defconst op-plus-2 86)

(defconst op-negate 87)

(defconst op-minus-2 88)

(defconst op-product-2 89)

(defconst op-divide-2 90)

(defconst op-mod-2 91)

(defconst op-lognot 92)

(defconst op-not 93)

(defconst op-logior-2 94)

(defconst op-logand-2 95)

(defconst op-equal 96)

(defconst op-eq 97)

(defconst op-num-eq 98)

(defconst op-num-noteq 99)

(defconst op-gtthan 100)

(defconst op-gethan 101)

(defconst op-ltthan 102)

(defconst op-lethan 103)

(defconst op-inc 104)

(defconst op-dec 105)

(defconst op-lsh 106)

(defconst op-zerop 107)

(defconst op-null 108)

(defconst op-atom 109)

(defconst op-consp 110)

(defconst op-listp 111)

(defconst op-numberp 112)

(defconst op-stringp 113)

(defconst op-vectorp 114)

(defconst op-catch-kludge 115)

(defconst op-throw 116)

(defconst op-unwind-pro 117)

(defconst op-un-unwind-pro 118)

(defconst op-fboundp 119)

(defconst op-boundp 120)

(defconst op-symbolp 121)

(defconst op-get 122)

(defconst op-put 123)

(defconst op-error-pro 124)

(defconst op-signal 125)

(defconst op-return 126)

(defconst op-reverse 127)

(defconst op-nreverse 128)

(defconst op-assoc 129)

(defconst op-assq 130)

(defconst op-rassoc 131)

(defconst op-rassq 132)

(defconst op-last 133)

(defconst op-mapcar 134)

(defconst op-mapc 135)

(defconst op-member 136)

(defconst op-memq 137)

(defconst op-delete 138)

(defconst op-delq 139)

(defconst op-delete-if 140)

(defconst op-delete-if-not 141)

(defconst op-copy-sequence 142)

(defconst op-sequencep 143)

(defconst op-functionp 144)

(defconst op-special-form-p 145)

(defconst op-subrp 146)

(defconst op-eql 147)

(defconst op-logxor-2 148)

(defconst op-set-current-buffer 176)

(defconst op-swap-buffer 177)

(defconst op-current-buffer 178)

(defconst op-bufferp 179)

(defconst op-markp 180)

(defconst op-windowp 181)

(defconst op-swap-window 182)

(defconst op-last-before-jmps 250)

(defconst op-jmp 251)

(defconst op-jn 252)

(defconst op-jt 253)

(defconst op-jnp 254)

(defconst op-jtp 255)

(defconst comp-max-1-byte-arg 5)

(defconst comp-max-2-byte-arg 255)

(defconst comp-max-3-byte-arg 65535)

(defvar comp-constant-alist (quote nil))

(defvar comp-constant-index 0)

(defvar comp-current-stack 0)

(defvar comp-max-stack 0)

(defvar comp-output nil)

(defvar comp-output-pc 0)

(defvar comp-macro-env (quote nil))

(defvar comp-const-env (quote nil))

(defvar comp-top-level-compiled (quote (if cond when unless let let* catch unwind-protect error-protect with-buffer with-window progn prog1 prog2 while and or)) 93037)

(defun compile-file (file-name) 93150 (interactive "fLisp file to compile:") (jade-byte-code "DIIIII01234
F$þ#


F#þHH|HJE" [comp-const-env comp-macro-env form dst-file src-file open file-name "r" concat 99 "w" format ";;; Source file: %s
;;; Compiled by %s@%s on %s
;;; Jade %d.%d
" user-login-name system-name current-time-string major-version-number minor-version-number (jade-byte-code "uDI1J
H    ]þ\\        F!þXL
‰ü3    F!ûEL‰üD    F!ûEIHþX
H
HûEv" [(jade-byte-code "    H    " [close dst-file src-file] 2) form message concat "Compiling " file-name "..." file-eof-p src-file read (defun defmacro defvar defconst require) comp-compile-top-form comp-top-level-compiled compile-form print dst-file write 10] 5) (error (jade-byte-code "D
3    þ    EHt" [concat file-name 99 fname file-exists-p delete-file error error-info] 3)) 2] 9))

(defun compile-directory (dir-name &optional force-p exclude-list) 93272 (interactive "DDirectory of Lisp files to compile:
P") (jade-byte-code "D    2nþEL
þLˆlþ<DL
6
6


þ;    EHMF\"HûHJE" [directory-files dir-name dir regexp-match "\\.jl$" exclude-list file-name-concat file concat 99 cfile file-newer-than-file-p compile-file] 3))

(defvar compile-lib-exclude-list (quote ("autoload.jl")))

(defun compile-lisp-lib (&optional force-p) 93522 (interactive "P") (jade-byte-code "DJ0E" [comp-write-docs compile-directory lisp-lib-dir force-p compile-lib-exclude-list] 4))

(put (quote compile-error) (quote error-message) "Compilation mishap")

(defun comp-error (&rest data) (jade-byte-code "}" [compile-error data] 2))

(defun comp-compile-top-form (form) (jade-byte-code "DL1aü2DP‚5þINHIOEHPQK    MKKûñ    aüpDQK    P‚56
üW
OûaP
KKF$H    P
MKKEûñaü­DPUP66þqþšQ    NHPKKF&EHûñaüÖDP6þÃqþÐQ    NEHûñaüäUHûñJüð    ûñIE" [form fun defun 1 comp-macro-env tmp comp-compile-lambda lambda 2 defmacro code defconst 3 doc value comp-write-docs add-doc-string comp-const-env defvar require comp-error "Shouldn't have got here!"] 6))

(defun compile-form (form) 93772 (jade-byte-code "DII123456    Hþ\"    
,E" [0 comp-output-pc comp-output comp-max-stack comp-current-stack comp-constant-index comp-constant-alist comp-compile-form form jade-byte-code comp-make-code-string comp-make-const-vec] 6))

(defun comp-make-code-string nil (jade-byte-code "D
nþLMLLRHMF$HûHE" [make-string comp-output-pc 42 comp-output data code-string] 3))

(defun comp-make-const-vec nil (jade-byte-code "D    34nþLMLLRHMF#HûHE" [make-vector comp-constant-index comp-constant-alist consts vec] 3))

(defun comp-inc-stack nil (jade-byte-code "hF dþF!" [comp-current-stack comp-max-stack] 2))

(defmacro comp-dec-stack (&optional n) (jade-byte-code "ü+û*+" [setq comp-current-stack n - 1-] 5))

(defun comp-compile-form (form) (jade-byte-code "Iaü    Hû
-Jaü    Hû
-yüfDI5    ü>    
Hûb
‚F%üOM    ûbJüa
HûbIEû
-nü
!DI6Lyþ}LzF&ü‰
û

F HLyþ LzF&ü¬
û
LF&HyüÀ    ûénþÌLaüÚ        ûéJüè
ûéIHMF HD6nþ
L    Hh&MF HûôH
HXF&EEû
-Jü
,    û
-I" [form comp-write-op 73 comp-inc-stack 74 val const-variable-p 16 comp-add-constant symbol-value comp-const-env comp-compile-form 24 fun compile-fun funcall macroexpand comp-macro-env comp-compile-constant lambda comp-compile-lambda comp-error "Bad function name" 0 i 8 comp-current-stack] 5))

(defun comp-compile-constant (form) (jade-byte-code "
H" [comp-write-op 16 comp-add-constant form comp-inc-stack] 4))

(defun comp-add-constant (const) (jade-byte-code "MÿKK!hF\"Hi" [const comp-constant-alist comp-constant-index] 2))

(defun comp-compile-body (body) (jade-byte-code "lü    Hû0nþ0L    HMþ'    HiF&HMF Hû" [body comp-write-op 73 comp-inc-stack comp-compile-form 72 comp-current-stack] 2))

(defun comp-compile-lambda (list) (jade-byte-code "DQI23Lqü+M#Pü\"P    û%P+F\"û:Jü9P*F\"û:IHLLaþP    L)
\"MF#H    
K    IK
E" [2 list new-head body lambda 1 comp-write-docs add-doc-string interactive nconc compile-form progn] 5))

(defmacro comp-make-label nil (jade-byte-code "" [(cons nil nil)] 1))

(defun comp-compile-jmp (opcode label) (jade-byte-code "    HLpüLj    HL_    û/Jü.MKOHVF%û/I" [comp-byte-out opcode label -8 255 comp-output-pc 2] 3))

(defun comp-set-label (label) (jade-byte-code "dþ        HNHMF$Hnþ4jLK_LhKKK&MF$Hû" [comp-output-pc 65535 comp-error "Jump destination overflow!" label -8 255 comp-output] 3))

(defun comp-write-op (opcode &optional arg) (jade-byte-code "lü    ûUgüV    ûUgü+V    H    ûUgüHV    Hj    H_    ûUJüT    
    ûUI" [arg comp-byte-out opcode 5 255 6 65535 7 -8 comp-error "Opcode overflow!"] 3))

(defun comp-byte-out (byte) (jade-byte-code "KK\"hF!" [byte comp-output-pc comp-output] 2))

(put (quote if) (quote compile-fun) (quote comp-compile-if))

(defun comp-compile-if (form) (jade-byte-code "P    HTbü.DIIK4
HiF&HP    H        EûlDIIK4IIK6


HiF&HP    H
H
    HiF&HQ    H        E" [comp-compile-form 1 form 3 end-label comp-compile-jmp 254 comp-current-stack 2 comp-set-label else-label 252 251 comp-compile-body] 3))

(put (quote when) (quote compile-fun) (quote comp-compile-when))

(defun comp-compile-when (form) (jade-byte-code "P    HDIIK3
HiF&HQ    H        E" [comp-compile-form 1 form end-label comp-compile-jmp 254 comp-current-stack comp-compile-body 2 comp-set-label] 3))

(put (quote unless) (quote compile-fun) (quote comp-compile-unless))

(defun comp-compile-unless (form) (jade-byte-code "P    HDIIK3
HiF&HQ    H        E" [comp-compile-form 1 form end-label comp-compile-jmp 255 comp-current-stack comp-compile-body 2 comp-set-label] 3))

(put (quote quote) (quote compile-fun) (quote comp-compile-quote))

(defun comp-compile-quote (form) (jade-byte-code "ML    " [comp-compile-constant form] 2))

(put (quote function) (quote compile-fun) (quote comp-compile-function))

(defun comp-compile-function (form) (jade-byte-code "MLF Hyü    û        " [form comp-compile-constant comp-compile-lambda] 3))

(put (quote while) (quote compile-fun) (quote comp-compile-while))

(defun comp-compile-while (form) (jade-byte-code "DIIK0IIK1    HP    H
HiF&H    
Q    H    HiF&H
H    HE" [tst-label end-label comp-set-label comp-compile-form 1 form comp-compile-jmp 254 comp-current-stack comp-compile-body 2 comp-write-op 72 251 comp-inc-stack] 3))

(put (quote progn) (quote compile-fun) (quote comp-compile-progn))

(defun comp-compile-progn (form) (jade-byte-code "M    " [comp-compile-body form] 2))

(put (quote prog1) (quote compile-fun) (quote comp-compile-prog1))

(defun comp-compile-prog1 (form) (jade-byte-code "P    HQ    H    HiF&" [comp-compile-form 1 form comp-compile-body 2 comp-write-op 72 comp-current-stack] 3))

(put (quote prog2) (quote compile-fun) (quote comp-compile-prog2))

(defun comp-compile-prog2 (form) (jade-byte-code "P    H    HiF%HP    HQ    H    HiF%" [comp-compile-form 1 form comp-write-op 72 comp-current-stack 2 comp-compile-body 3] 3))

(put (quote setq) (quote compile-fun) (quote comp-compile-setq))

(defun comp-compile-setq (form) (jade-byte-code "MF HnþMnþ>ML    HQnÿ#    HHL
HiF&HQF Hû" [form comp-compile-form 2 comp-write-op 70 comp-inc-stack 32 comp-add-constant comp-current-stack] 4))

(put (quote set) (quote compile-fun) (quote comp-compile-set))

(defun comp-compile-set (form) (jade-byte-code "P    H    HHP    H    HXF&" [comp-compile-form 2 form comp-write-op 70 comp-inc-stack 1 65 comp-current-stack] 3))

(put (quote fset) (quote compile-fun) (quote comp-compile-fset))

(defun comp-compile-fset (form) (jade-byte-code "P    H    HHP    H    HXF&" [comp-compile-form 2 form comp-write-op 70 comp-inc-stack 1 67 comp-current-stack] 3))

(put (quote let*) (quote compile-fun) (quote comp-compile-let*))

(defun comp-compile-let* (form) (jade-byte-code "DML1    HnþTLnü*DL4M    HL
EûDJüC    H    HL
ûDIH
iF&
HMF!Hû    HQ    H    E" [form list comp-write-op 68 tmp comp-compile-body 48 comp-add-constant 73 comp-inc-stack comp-current-stack 2 69] 4))

(put (quote let) (quote compile-fun) (quote comp-compile-let))

(defun comp-compile-let (form) (jade-byte-code "DMLI12    HnþFLnü&LLKF!HLM    û=Jü<LKF!H    Hû=IHMF\"HûHnþe    L
H
iF&
HMF!HûGHQ    H    E" [form sym-stk list comp-write-op 68 comp-compile-body 73 comp-inc-stack 48 comp-add-constant comp-current-stack 2 69] 4))

(put (quote defun) (quote compile-fun) (quote comp-compile-defun))

(defun comp-compile-defun (form) (jade-byte-code "P    H    HHQK        H        H
    HXF&" [comp-compile-constant 1 form comp-write-op 70 comp-inc-stack comp-compile-lambda lambda 2 71 67 comp-current-stack] 5))

(put (quote defmacro) (quote compile-fun) (quote comp-compile-defmacro))

(defun comp-compile-defmacro (form) (jade-byte-code "P    H    HH    QK    K    H
    H    H    XF&" [comp-compile-constant 1 form comp-write-op 70 comp-inc-stack macro comp-compile-lambda lambda 2 71 67 comp-current-stack] 6))

(put (quote cond) (quote compile-fun) (quote comp-compile-cond))

(defun comp-compile-cond (form) (jade-byte-code "DIIK0MF!Hnþ_DLIIK23L    HiF%HMnüG
HM    HiF%H    
H
    ûUJüT
ûUIHMF!EHû
H    HH
    E" [end-label form next-label subl comp-compile-form comp-current-stack comp-compile-jmp 252 comp-compile-body 251 comp-set-label 255 comp-write-op 73 comp-inc-stack] 3))

(put (quote or) (quote compile-fun) (quote comp-compile-or))

(defun comp-compile-or (form) (jade-byte-code "DIIK0MF!Hnþ+L    HiF#HMþ\"
HMF!Hû
HH    E" [end-label form comp-compile-form comp-current-stack comp-compile-jmp 255 comp-inc-stack comp-set-label] 3))

(put (quote and) (quote compile-fun) (quote comp-compile-and))

(defun comp-compile-and (form) (jade-byte-code "DIIK0MF!Hnþ+L    HiF#HMþ\"
HMF!Hû
HH    E" [end-label form comp-compile-form comp-current-stack comp-compile-jmp 254 comp-inc-stack comp-set-label] 3))

(put (quote catch) (quote compile-fun) (quote comp-compile-catch))

(defun comp-compile-catch (form) (jade-byte-code "QK        HP    H    HiF&" [comp-compile-constant compile-form progn 2 form 1 comp-write-op 115 comp-current-stack] 5))

(put (quote unwind-protect) (quote compile-fun) (quote comp-compile-unwind-pro))

(defun comp-compile-unwind-pro (form) (jade-byte-code "QK        H    HiF&H    P    H
    " [comp-compile-constant compile-form progn 2 form comp-write-op 117 comp-current-stack comp-compile-form 1 118] 5))

(put (quote error-protect) (quote compile-fun) (quote comp-compile-error-protect))

(defun comp-compile-error-protect (form) (jade-byte-code "D1MF\"Hnÿ
HL        HMF\"HnþQDL6nÿ4
HL    MK    *    HM\"hF!EHûHh    H
    HXF&E" [0 i form comp-error "No FORM to `error-protect'" comp-compile-constant compile-form handler "Badly formed handler to `error-protect'" progn comp-write-op 124 comp-current-stack] 5))

(put (quote list) (quote compile-fun) (quote comp-compile-list))

(defun comp-compile-list (form) (jade-byte-code "D1MF\"HnþL    Hh!MF\"HûH
HiXF&E" [0 count form comp-compile-form comp-write-op 40 comp-current-stack] 3))

(put (quote with-buffer) (quote compile-fun) (quote comp-compile-with-buffer))

(defun comp-compile-with-buffer (form) (jade-byte-code "P    H    HQ    H    H    H    H    iF&    " [comp-compile-form 1 form comp-write-op 177 comp-compile-body 2 71 72 comp-current-stack] 3))

(put (quote with-window) (quote compile-fun) (quote comp-compile-with-window))

(defun comp-compile-with-window (form) (jade-byte-code "P    H    HQ    H    H    H    H    iF&    " [comp-compile-form 1 form comp-write-op 182 comp-compile-body 2 71 72 comp-current-stack] 3))

(put (quote -) (quote compile-fun) (quote comp-compile-minus))

(put (quote -) (quote compile-opcode) op-minus-2)

(defun comp-compile-minus (form) (jade-byte-code "Tcü    ûML    H    " [form 2 comp-compile-binary-op comp-compile-form comp-write-op 87] 2))

(defun comp-compile-0-args (form) (jade-byte-code "Lz
H" [comp-write-op form compile-opcode 0 comp-inc-stack] 3))

(defun comp-compile-1-args (form) (jade-byte-code "P    HLz
" [comp-compile-form 1 form comp-write-op compile-opcode 0] 3))

(defun comp-compile-2-args (form) (jade-byte-code "P    HP    HLz
HiF&" [comp-compile-form 1 form 2 comp-write-op compile-opcode 0 comp-current-stack] 3))

(defun comp-compile-3-args (form) (jade-byte-code "P    HP    HP    HLz
HXF&" [comp-compile-form 1 form 2 3 comp-write-op compile-opcode 0 comp-current-stack] 3))

(defun comp-compile-binary-op (form) (jade-byte-code "DLz2MF HTeÿ
HL    HMF HnþAL    H    HiF&HMF Hû\"E" [form compile-opcode opcode 2 comp-error "Too few args to binary operator" comp-compile-form comp-write-op comp-current-stack] 3))

(jade-byte-code "{H{H{H{H{H    {H
{H
{H{H{H{H{H{H{H{H{H{H{H{H{H{H{H{H{H{H{H {H !{H\"{H\"#{H${H$%{H&{H&'{H({H(){H*{H*+{H,{H,-{H.{H./{H0{H01{H2{H23{H4{H45{H6{H67{H8{H89{H:{H:;{H<{H<={H>{H>?{H@{H@A{HB{HBC{HD{HDE{HF{HFG{HH{HHI{HJ{HJK{HL{HLM{HN{HNO{HP{HPQ{HR{HRS{HT{HTU{HV{HVW{HX{HXY{HZ{HZ[{H\\{H\\]{H^{H^_{H`{H`a{Hb{Hbc{Hd{Hde{Hf{Hfg{Hh{Hhi{Hj{Hjk{Hl{Hlm{Hn{Hno{Hp{Hpq{Hr{Hrs{Ht{Htu{Hv{Hvw{Hx{Hxy{Hz{Hz{{H|{H|}{H~{H~{H€{H€{H‚{H‚ƒ{H„{H„…{H†{H†‡{Hˆ{Hˆ‰{HŠ{HŠ‹{HŒ{HŒ{HŽ{HŽ{H{H‘{H’{H’“{H”{H”•{H–{H–—{" [cons compile-fun comp-compile-2-args compile-opcode 75 car comp-compile-1-args 76 cdr 77 rplaca 78 rplacd 79 nth 80 nthcdr 81 aset comp-compile-3-args 82 aref 83 length 84 eval 85 + comp-compile-binary-op 86 * 89 / 90 % 91 lognot 92 not 93 logior 94 logxor 148 logand 95 equal 96 eq 97 = 98 /= 99 > 100 < 102 >= 101 <= 103 1+ 104 1- 105 lsh 106 zerop 107 null 108 atom 109 consp 110 listp 111 numberp 112 stringp 113 vectorp 114 throw 116 fboundp 119 boundp 120 symbolp 121 get 122 put 123 signal 125 return 126 reverse 127 nreverse 128 assoc 129 assq 130 rassoc 131 rassq 132 last 133 mapcar 134 mapc 135 member 136 memq 137 delete 138 delq 139 delete-if 140 delete-if-not 141 copy-sequence 142 sequencep 143 functionp 144 special-form-p 145 subrp 146 eql 147 set-current-buffer 176 current-buffer 178 bufferp 179 markp 180 windowp 181] 3)